Исследовать данные о поведении пользователей онлайн-кинотеатра KION, используя статистические методы.
Познакомить читателя с данными и сделать выводы о пользователях
онлайн-кинотеатра КИОН. Для анализа использовать переменные:
age, income, total_dur,
rating_kp, sex. Проанализировать каждую
переменную, которую будем использовать для выполнения заданий.
Датасет включает в себя информацию о взаимодействии пользователей с контентом, демографическую информация о пользователях и мета-информацию о фильмах. Данные собраны на основе анализа пользователей сервиса в период с 13 марта 2021 года по 22 августа 2022 года.
Загружаем данные (в формате CSV) в датафрейм
df = read.csv('task_data.csv')
head(df, 1)
## user_id item_id last_watch_dt total_dur watched_pct X content_type
## 1 176549 9506 2021-05-11 4250 72 1571 film
## title title_orig release_year genres
## 1 Холодное сердце Frozen 2013 фэнтези, мультфильм, музыкальные
## countries for_kids age_rating studios directors
## 1 США NA 0 Крис Бак, Дженнифер Ли
## actors
## 1 Кристен Белл, Идина Мензел, Джонатан Грофф, Джош Гад, Сантино Фонтана, Алан Тьюдик, Киран Хайндс, Крис Уильямс, Стивен Дж. Андерсон, Майа Уилсон, Киаран Хиндс, Морис ЛаМарш, Дженнифер Ли, Дара МакГарри, Фред Татаскьор
## description
## 1 Когда сбывается древнее предсказание, и королевство погружается в объятия вечной зимы, трое бесстрашных героев — принцесса Анна, отважный Кристофф и его верный олень Свен — отправляются в горы, чтобы найти сестру Анны, Эльзу, которая может снять со страны леденящее заклятие. По пути их ждет множество увлекательных сюрпризов и захватывающих приключений: встреча с мистическими троллями, знакомство с очаровательным снеговиком по имени Олаф, горные вершины покруче Эвереста и магия в каждой снежинке. Анне и Кристоффу предстоит сплотиться и противостоять могучей стихии, чтобы спасти королевство и тех, кто им дорог.
## keywords
## 1 королева, мюзикл, принцесса, предательство, снеговик, олень, проклятие, снег, тролль, альпинист, сцена после титров, женщина-режиссёр, 3d, 3D, CGI-анимация, Альпинист, Антропоморфизм, Арестованный злодей, Бальные танцы, Блокбастер, Блочный лед, Броня, Владелец магазина, Водный фонтан, Волк, Волшебная сила, Волшебство, Ганс Христиан Андерсен, Героиня, Главный герой - женщина, Гора, Государственная измена, Девочка, Дисней, Дровосек, Езда на лошади, Женщина-герой, Женщина-режиссёр, Жертвоприношение, Замок, Замороженный заживо, Зима, Изоляция, Книга, Комический персонаж, Кораблекрушение, Королева, Королевство, Коронация, Лассо, Лед, Лес, Ложное обвинение, Любовь сестры, Маяк, Между жизнью и смертью (клиническая смерть), Монстр, Морковь, Музыка к фильму в исполнении оркестра, Название, сказанное персонажем, Настоящая любовь, Нет титров в начале фильма, Обман, Обман смерти, Обрыв, Оригинальное название из одного слова, Отношения сестёр, Отчаяние, Отшельник (аскет), Падение в воду, Пение, Первая часть, Перчатки, Пила, По мотивам сказки, Подсматривание в замочную скважину, Предатель, Предательство, Предложение вступить в брак, Преследуемый волками, Принц, Принцесса, Путешествие, Родные братья и сестры, Самопожертвование, Санки, Сарай, Сверхъестественные способности, Северное полярное сияние, Северный олень, Сестра, Сирота, Сказка, Склад, Смерть родителей, Снег, Снеговик, Снежная буря, Страстное увлечение, Сцена после финальных титров, Сцена, где рот закрывают ладонью, Счастливый конец, 2013, соединенные штаты, холодное, сердце
## valid_from_dttm rating_kp age income sex kids_flg
## 1 2019-11-01 13:00:00 age_35_44 income_40_60 М 0
Посмотрим на размер датафрейма
dim(df)
## [1] 15768 25
В данных 15768 наблюдений (строк) и 25 переменных (столбцов)
Посмотрим на переменные и их типы
str(df, vec.len = 2)
| Переменная | Тип данных | Описание |
|---|---|---|
user_id |
int | ID пользователя |
age |
chr | возрастная группа пользователя
|
sex |
chr | пол пользователя
|
income |
chr | доход пользователя
|
kids_flg |
int | флаг «наличие ребенка» |
item_id |
int | ID контента |
content_type |
chr | тип контента (фильм, сериал) |
title |
chr | название на русском |
title_orig |
chr | название оригинальное |
genres |
chr | жанры из источника (онлайн-кинотеатры) |
countries |
chr | страны |
for_kids |
int | флаг «контент для детей» |
age_rating |
int | возрастной рейтинг |
studios |
chr | студии |
directors |
chr | режиссеры |
actors |
chr | актеры |
keywords |
chr | ключевые слова |
description |
chr | описание |
valid_from_dttm |
chr | дата, с которой контент доступен на KION |
rating_kp |
chr | рейтинг на Кинопоиске |
last_watch_dt |
chr | дата последнего просмотра |
total_dur |
int | общая продолжительность всех просмотров данного контента в секундах |
watched_pct |
int | - |
X |
int | - |
release_year |
int | год релиза |
Найдем, сколько уникальных пользователей, фильмов и взаимодействий содержится в датасете
print(paste("Уникальных пользователей:", length(unique(df$user_id))))
## [1] "Уникальных пользователей: 15238"
print(paste("Уникальных фильмов / сериалов:", length(unique(df$item_id))))
## [1] "Уникальных фильмов / сериалов: 3204"
print(paste("Уникальных взаимодействия:", nrow(unique(df[c("user_id", "item_id")]))))
## [1] "Уникальных взаимодействия: 15768"
Чтобы в дальнейшем было удобнее работать с переменными, преобразуем их типы:
rating_kp (рейтинг на Кинопоиске) из
character (символьный тип данных) в numeric (числовой
тип данных)
sex (пол пользователя), age (возраст),
income (доход) и content_type (тип контента)
из character в factor (категориальный)
library(readr)
df$rating_kp <- as.numeric(parse_number(df$rating_kp, locale = locale(decimal_mark = ",")))
df$sex <- factor(df$sex, levels = c("Ж", "М"))
df$age <- factor(df$age, levels = c("age_18_24", "age_25_34", "age_35_44", "age_45_54", "age_55_64", "age_65_inf"), ordered = TRUE)
df$income <- factor(df$income, levels = c("income_0_20", "income_20_40", "income_40_60", "income_60_90", "income_90_150", "income_150_inf"), ordered = TRUE)
df$content_type <- factor(df$content_type, levels = c("film", "series"))
Посмотрим на количество пропусков в данных
library(naniar)
gg_miss_var(df) # график пропусков по столбцам
Видим, что интересующие нас переменные sex,
age, income и rating_kp содержат
пропущенные значения. Избавимся от наблюдений с пропусками
library(dplyr)
df_clean <- df %>%
filter(!is.na(sex)) %>%
filter(!is.na(age)) %>%
filter(!is.na(income)) %>%
filter(!is.na(rating_kp))
Рассчитаем описательные статистики для ключевых переменных
age (factor - качественная порядковая)
income (factor - качественная порядковая)
total_dur (int - количественная
относительная)
rating_kp (numeric - количественная
интервальная)
sex (factor - качественная номинальная)
Оценим, содержат ли количественные данные выбросы.
Используем метод межквартильного размаха (IQR) из
boxplot.stats
outliers_rating_kp <- boxplot.stats(df_clean$rating_kp)$out
outliers_total_dur <- boxplot.stats(df_clean$total_dur)$out
print(paste("Количество выбросов в переменной rating_kp:", length(outliers_rating_kp)))
## [1] "Количество выбросов в переменной rating_kp: 207"
print(paste("Количество выбросов в переменной total_dur:", length(outliers_total_dur)))
## [1] "Количество выбросов в переменной total_dur: 890"
Посмотрим, в каком диапазоне сосредоточены выбросные значения
print(paste("Диапазан выбросов в переменной rating_kp:", min(outliers_rating_kp), "-", max(outliers_rating_kp)))
## [1] "Диапазан выбросов в переменной rating_kp: 0 - 3.99"
print(paste("Диапазан выбросов в переменной total_dur:", min(outliers_total_dur), "-", max(outliers_total_dur)))
## [1] "Диапазан выбросов в переменной total_dur: 17106 - 3502510"
Выбросы в переменной rating_kp являются просто
низкими значениями рейтинга, которых не слишком много в данных (207
значений из 10004). Мы оставим их в рассмотрении, уберем только оценки,
равные 0
Выбросы в переменной total_dur - это очень большие
значения (от 5 до 972 часов просмотра). Они могут сильно искажать
распределение данных, что значимо для дальнейшего проведения
статистических тестов. Также из данных стоит убрать слишком маленькие
значения - менее 60 секунд
df_clean <- df_clean %>%
filter(rating_kp != 0,
between(total_dur, 60, min(outliers_total_dur) - 1)
)
print(paste("Количество наблюдений после удаления пропущенных значений и выбросов:", nrow(df_clean)))
## [1] "Количество наблюдений после удаления пропущенных значений и выбросов: 7837"
Посмотрим на количество наблюдений каждой категории для порядковых переменных
print(summary(df_clean$age))
## age_18_24 age_25_34 age_35_44 age_45_54 age_55_64 age_65_inf
## 1038 2215 2247 1358 598 381
print(summary(df_clean$income))
## income_0_20 income_20_40 income_40_60 income_60_90 income_90_150
## 172 4427 2443 651 137
## income_150_inf
## 7
print(summary(df_clean$sex))
## Ж М
## 3727 4110
Посмотрим на минимальные и максимальные значения количественных переменных
rating_kp
summary(df_clean$rating_kp)["Min."]
## Min.
## 2.3
summary(df_clean$rating_kp)["Max."]
## Max.
## 9.2
total_dur
summary(df_clean$total_dur)["Min."]
## Min.
## 60
summary(df_clean$total_dur)["Max."]
## Max.
## 17066
Меры центральной тенденции:
rating_kp и total_durprint(paste(round(mean(df_clean$rating_kp), digits = 2), "- средний балл рейтинга фильмов на Кинопоиске"))
## [1] "6.62 - средний балл рейтинга фильмов на Кинопоиске"
print(paste(round(mean(df_clean$total_dur)), "- средняя продолжительность всех просмотров контента (сек)"))
## [1] "4090 - средняя продолжительность всех просмотров контента (сек)"
rating_kp, total_dur, age,
income# для количественных данных оценим медиану напрямую
print(paste(median(df_clean$rating_kp), "- серединное значение рейтинга фильмов на Кинопоиске"))
## [1] "6.7 - серединное значение рейтинга фильмов на Кинопоиске"
print(paste(median(df_clean$total_dur), "- серединное значение продолжительности всех просмотров контента (сек)"))
## [1] "3209 - серединное значение продолжительности всех просмотров контента (сек)"
# для порядковых данных оценим медиану с помощью квантиля уровня 0.5
print(paste(quantile(df_clean$age, probs = 0.5, type = 1), "- серединное значение возрастной группы пользователей"))
## [1] "age_35_44 - серединное значение возрастной группы пользователей"
print(paste(quantile(df_clean$income, probs = 0.5, type = 1), "- серединное значение дохода пользователей"))
## [1] "income_20_40 - серединное значение дохода пользователей"
age, income, total_dur,
rating_kp и sexlibrary(modeest)
print(paste(mlv(df_clean$age, method = "mfv"), "- самая часто встречающаяся возрастная группа пользователей"))
## [1] "age_35_44 - самая часто встречающаяся возрастная группа пользователей"
print(paste(mlv(df_clean$income, method = "mfv"), "- самый часто встречающийся доход пользователей"))
## [1] "income_20_40 - самый часто встречающийся доход пользователей"
print(paste(mlv(df_clean$total_dur, method = "mfv"), "- самая часто встречающаяся продолжительность всех просмотров контента (сек)"))
## [1] "86 - самая часто встречающаяся продолжительность всех просмотров контента (сек)"
print(paste(mlv(df_clean$rating_kp, method = "mfv"), "- самый часто встречающийся рейтинг фильмов на Кинопоиске"))
## [1] "6.9 - самый часто встречающийся рейтинг фильмов на Кинопоиске"
print(paste(mlv(df_clean$sex, method = "mfv"), "- самый часто встречающийся пол пользователя"))
## [1] "М - самый часто встречающийся пол пользователя"
Распределения данных:
rating_kp
library(ggplot2)
library(plotly)
ggplotly(
ggplot(df_clean, aes(x = rating_kp)) +
geom_histogram(bins=8, fill = "orange", color = "#784e44") +
scale_x_continuous(n.breaks = 8) +
theme_minimal() +
theme(panel.grid = element_blank()) +
labs(title = "Распределение рейтинга фильмов на Кинопоиске",
x = "Рейтинг (баллы)",
y = "Частота")
)
Основная масса данных сосредоточена в диапазоне 6–8 баллов, с пиком около 7
Распределение имеет отрицательную асимметрию (левый хвост длиннее), так как есть низкие рейтинги с небольшой частотой
Низкие значения (2–3) встречаются редко, но присутствуют
qqnorm(df_clean$rating_kp, main = "Q-Q Plot для переменной rating_kp", col = "orange")
qqline(df_clean$rating_kp, col = "#784e44")
Основная часть данных приближена к нормальному распределению, но есть асимметрия у хвостов
print(paste(round(max(df_clean$rating_kp) - min(df_clean$rating_kp), 2), "- разница между минимальным и максимальным значением (размах) рейтинга фильмов на Кинопоиске"))
## [1] "6.9 - разница между минимальным и максимальным значением (размах) рейтинга фильмов на Кинопоиске"
print(paste(round(var(df_clean$rating_kp), 2), "- дисперсия (баллов²)"))
## [1] "1.06 - дисперсия (баллов²)"
print(paste(round(sd(df_clean$rating_kp), 2), "- стандартное отклонение значений от среднего (корень из дисперсии)"))
## [1] "1.03 - стандартное отклонение значений от среднего (корень из дисперсии)"
total_dur
ggplotly(
ggplot(df_clean, aes(x = total_dur)) +
geom_histogram(bins = 20, fill = "lightblue", color = "#45818e") +
theme_minimal() +
theme(panel.grid = element_blank()) +
labs(title = "Распределение продолжительности всех просмотров контента",
x = "Продолжительность просмотра (сек)",
y = "Частота")
)
Основная масса просмотров контента приходится на очень короткие промежутки времени, близкие к 1 минуте. Это указывает на то, что подавляющее большинство пользователей заканчивают просмотр очень быстро
Частота резко убывает с увеличением длительности просмотра, что указывает на правостороннее распределение (положительная асимметрия)
qqnorm(df_clean$total_dur, main = "Q-Q Plot для переменной total_dur", col = "lightblue")
qqline(df_clean$total_dur, col = "#45818e")
Точки заметно отклоняются от линии нормального распределения (особенно в хвостах)
print(paste(round(max(df_clean$total_dur) - min(df_clean$total_dur), 2), "- разница между минимальным и максимальным значением (размах) продолжительности всех просмотров контента (сек)"))
## [1] "17006 - разница между минимальным и максимальным значением (размах) продолжительности всех просмотров контента (сек)"
print(paste(round(var(df_clean$total_dur)), "- дисперсия (сек²)"))
## [1] "14041400 - дисперсия (сек²)"
print(paste(round(sd(df_clean$total_dur)), "- стандартное отклонение значений от среднего (корень из дисперсии)"))
## [1] "3747 - стандартное отклонение значений от среднего (корень из дисперсии)"
Столбчатые диаграммы для частотного распределения категориальных данных
age
ggplotly(
ggplot(df_clean, aes(x = age)) +
geom_bar(fill = "#6aa84f", color = "#274e13") +
theme_minimal() +
theme(panel.grid = element_blank()) +
labs(title = "Распределение возрастных групп пользователей",
x = "Возраст",
y = "Количество")
)
Наибольшие возрастные группы пользователей: 25–34 и 35-44 года с количеством пользователей около 2200 человек
Возрастные группы 55-64 и 65+ представлены в довольно небольшом количестве (менее 600 пользователей в каждой)
income
ggplotly(
ggplot(df_clean, aes(x = income)) +
geom_bar(fill = "#b4a7d6", color = "#674ea7") +
theme_minimal() +
theme(panel.grid = element_blank()) +
labs(title = "Распределение дохода пользователей",
x = "Доход (тысяч рублей)",
y = "Количество")
)
Диапазон 20–40 тысяч рублей выделяется как самая многочисленная категория дохода пользователей
Группы с доходом 0–20, 90-150 и 150+ тысяч рублей имеют крайне небольшую численность
sex
ggplotly(
ggplot(df_clean, aes(x = sex)) +
geom_bar(fill = "#d5a6bd", color = "#a64d79") +
theme_minimal() +
theme(panel.grid = element_blank()) +
labs(title = "Распределение пола",
x = "Пол",
y = "Количество")
)
Женщин в выборке немного меньше, чем мужчин. Однако группы относительно сбалансированы, нет экстремального перевеса одной категории над другой
H₀ (нулевая гипотеза): Нет статистически значимой разницы в средней продолжительности просмотра контента между группами с разным уровнем дохода
H₁ (альтернативная гипотеза): Существует статистически значимая разница в средней продолжительности просмотра контента между хотя бы двумя группами с разным уровнем дохода
Поскольку в переменной income представлено 6 групп
пользователей с различным уровнем дохода, будем использовать
статистический тест для более двух независимых выборок
(ANOVA / Краскела-Уоллиса)
# гистограммы распределения
ggplot(df_clean, aes(x = total_dur)) +
geom_histogram(bins=10, fill = "lightblue", color = "#674ea7") +
facet_wrap(~ income) +
ggtitle("Распределение продолжительности просмотра (группы по доходу)") +
labs(x = "Продолжительность просмотра (сек)",
y = "Частота") +
theme_minimal()
# тест Шапиро-Уилка
df_clean %>%
group_by(income) %>%
summarise(
p.value = shapiro.test(total_dur)$p.value
)
## # A tibble: 6 × 2
## income p.value
## <ord> <dbl>
## 1 income_0_20 4.82e-11
## 2 income_20_40 1.04e-48
## 3 income_40_60 9.60e-38
## 4 income_60_90 8.63e-21
## 5 income_90_150 5.31e- 9
## 6 income_150_inf 1.35e- 2
# qq-plot
ggplot(df_clean, aes(sample = total_dur)) +
stat_qq(col = "lightblue") +
stat_qq_line(col = "#674ea7") +
facet_wrap(~ income) +
ggtitle("QQ-plot продолжительности просмотра (группы по доходу)") +
theme_minimal()
Вновь убеждаемся, что данные в total_dur далеки от
нормального распределения, даже при разбиении их на группы по доходу
пользователей. Поэтому нам необходимо использовать непараметрический
аналог ANOVA - тест Краскела-Уоллиса
library(car)
# тест Левена
leveneTest(total_dur ~ income, data = df_clean)
## Levene's Test for Homogeneity of Variance (center = median)
## Df F value Pr(>F)
## group 5 2.8369 0.01454 *
## 7831
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
Однако видим, что по результатам теста Левена, мы получили p-value = 0.0145. (> заданного уровня значимости 0.05). На основе этого, можем сделать вывод о равенстве дисперсий в группах
kruskal.test(total_dur ~ income, data = df_clean)
##
## Kruskal-Wallis rank sum test
##
## data: total_dur by income
## Kruskal-Wallis chi-squared = 9.295, df = 5, p-value = 0.09786
По результатам теста Краскела-Уоллиса: p-value = 0.0979 (> заданного уровня значимости 0.05), значит мы НЕ можем отвергнуть нулевую гипотезу. Средняя продолжительность просмотра контента между группами с разным уровнем дохода НЕ имеет статистически значимых различий
Посмотрим на медианы, квартили и кол-во наблюдений для каждой группы
df_clean %>%
group_by(income) %>%
summarise(
median = median(total_dur),
Q1 = quantile(total_dur, 0.25),
Q3 = quantile(total_dur, 0.75),
n = n()
)
## # A tibble: 6 × 5
## income median Q1 Q3 n
## <ord> <dbl> <dbl> <dbl> <int>
## 1 income_0_20 3066. 663 6512. 172
## 2 income_20_40 3089 675 6496. 4427
## 3 income_40_60 3449 764. 6624. 2443
## 4 income_60_90 3306 800. 6850 651
## 5 income_90_150 3837 875 7472 137
## 6 income_150_inf 613 351 10689 7
Действительно видим, что медиана и значение других квартилей не слишком отличаются в разных группах. Видим более существенное отличие только для группы с income_150_inf, однако в силу небольшого количества измерений (7 штук), нельзя говорить о его статистической значимости
ggplot(df_clean, aes(x = income, y = total_dur)) +
geom_boxplot(fill = "lightblue", color = "#674ea7") +
labs(title = "Продолжительность просмотра в зависимости от дохода",
x = "Доход (тысяч рублей)",
y = "Продолжительность просмотра (сек)") +
theme_minimal()
H₀ (нулевая гипотеза): Между женщинами и мужчинами нет статистически значимой разницы в средней продолжительности просмотра контента
H₁ (альтернативная гипотеза): Между женщинами и мужчинами существует статистически значимая разница в средней продолжительности просмотра контента
Поскольку нам предстоит анализировать две группы пользователей (Ж и М), будем использовать статистический тест для двух независимых выборок (t-Стьюдента / U-Манна-Уитни)
# гистограммы распределения
ggplot(df_clean, aes(x = total_dur)) +
geom_histogram(bins = 10, fill = "lightblue", color = "#a64d79") +
facet_wrap(~ sex) +
ggtitle("Распределение продолжительности просмотра (группы по полу)") +
labs(x = "Продолжительность просмотра (сек)",
y = "Частота") +
theme_minimal()
# тест Шапиро-Уилка
df_clean %>%
group_by(sex) %>%
summarise(
p.value = shapiro.test(total_dur)$p.value
)
## # A tibble: 2 × 2
## sex p.value
## <fct> <dbl>
## 1 Ж 2.13e-45
## 2 М 4.48e-47
# qq-plot
ggplot(df_clean, aes(sample = total_dur)) +
stat_qq(col = "lightblue") +
stat_qq_line(col = "#a64d79") +
facet_wrap(~ sex) +
ggtitle("QQ-plot продолжительности просмотра, сгруппированные по полу") +
theme_minimal()
Данные о продолжительности просмотра контента в зависимости от пола не соответствуют нормальному распределению. Поэтому нам необходимо использовать непараметрический аналог t-теста Стьюдента - тест Манна-Уитни
# тест Левена
leveneTest(total_dur ~ sex, data = df_clean)
## Levene's Test for Homogeneity of Variance (center = median)
## Df F value Pr(>F)
## group 1 2.0781 0.1495
## 7835
По результатам теста Левена, p-value = 0.1495. (> заданного уровня значимости 0.05), что свидетельствует о равенстве дисперсий в двух выборках
wilcox.test(total_dur ~ sex, data = df_clean)
##
## Wilcoxon rank sum test with continuity correction
##
## data: total_dur by sex
## W = 7768864, p-value = 0.272
## alternative hypothesis: true location shift is not equal to 0
По результатам теста Манна-Уитни: p-value = 0.272 (> заданного уровня значимости 0.05), значит мы принимаем нулевую гипотезу. Средняя продолжительность просмотра контента между женщинами и мужчинами НЕ имеет статистически значимых различий
Медианы, квартили и кол-во наблюдений для каждой группы
df_clean %>%
group_by(sex) %>%
summarise(
median = median(total_dur),
Q1 = quantile(total_dur, 0.25),
Q3 = quantile(total_dur, 0.75),
n = n()
)
## # A tibble: 2 × 5
## sex median Q1 Q3 n
## <fct> <dbl> <dbl> <dbl> <int>
## 1 Ж 3277 732 6662. 3727
## 2 М 3147 707 6541 4110
Данные о продолжительности просмотра слегка выше для женщин, однако различия не значимы
ggplot(df_clean, aes(x = sex, y = total_dur)) +
geom_boxplot(fill = "lightblue", color = "#a64d79") +
labs(title = "Продолжительность просмотра в зависимости от пола",
x = "Пол",
y = "Продолжительность просмотра (сек)") +
theme_minimal()
H₀ (нулевая гипотеза): Нет статистически значимой связи между рейтингом фильма на Кинопоиске и продолжительностью его просмотра
H₁ (альтернативная гипотеза): Существует статистически значимая связь между рейтингом фильма на Кинопоиске и продолжительностью его просмотра
Поскольку нам нужно оценить степень взаимосвязи между двумя переменными, будем использовать корреляционный анализ (коэффициент Пирсона, Спирмана или Кендалла)
Обе переменные являются количественными:
rating_kp - интервальная, поскольку позволяет
измерять разницу между значениями, но не имеет абсолютного нуля
total_dur - относительная, т.к. может иметь
абсолютный ноль, который означает полное отсутствие измеряемого
признака
library(gridExtra)
# гистограммы распределения
grid.arrange(
ggplot(df_clean, aes(x = rating_kp)) +
geom_histogram(bins=8, fill = "orange", color = "#784e44") +
scale_x_continuous(n.breaks = 8) +
theme_minimal() +
labs(title = "Распределение рейтинга\nфильмов на Кинопоиске",
x = "Рейтинг (баллы)",
y = "Частота"),
ggplot(df_clean, aes(x = total_dur)) +
geom_histogram(bins = 15, fill = "lightblue", color = "#45818e") +
theme_minimal() +
labs(title = "Распределение продолжительности\nпросмотров контента",
x = "Продолжительность просмотра (сек)",
y = "Частота"),
ncol=2
)
# Q-Q plot
grid.arrange(
ggplot(df_clean, aes(sample = rating_kp)) +
stat_qq(color = "orange") +
stat_qq_line(col = "#784e44") +
labs(title = "Q-Q Plot для rating_kp") +
theme_minimal(),
ggplot(df_clean, aes(sample = total_dur)) +
stat_qq(color = "lightblue") +
stat_qq_line(col = "#45818e") +
labs(title = "Q-Q Plot для total_dur") +
theme_minimal(),
ncol = 2
)
Поскольку выборка слишком большая для проведения классического теста Шапиро-Уилка, используем тест Андерсона-Дарлинга (для n > 5000)
library(nortest)
print(ad.test(df_clean$rating_kp))
##
## Anderson-Darling normality test
##
## data: df_clean$rating_kp
## A = 45.444, p-value < 2.2e-16
print(ad.test(df_clean$total_dur))
##
## Anderson-Darling normality test
##
## data: df_clean$total_dur
## A = 243.7, p-value < 2.2e-16
Так как обе переменные не распределены нормально, коэффициент Пирсона нам НЕ подходит, используем непараметрический аналог - коэффициент корреляции Спирмена или Кендалла
grid.arrange(
ggplot(df_clean, aes(y = rating_kp)) +
geom_boxplot(fill = "orange", color = "#784e44") +
labs(title = "Boxplot для переменной rating_kp") +
theme_minimal(),
ggplot(df_clean, aes(y = total_dur)) +
geom_boxplot(fill = "lightblue", color = "#45818e") +
labs(title = "Boxplot для переменной total_dur") +
theme_minimal(),
ncol = 2
)
Несмотря на то, что мы уже избавлялись от выбросных значений, в них все еще присутствуют выбросы. Таким образом, лучше использовать коэффициент корреляции Кендалла, который к ним более устойчив
cor.test(df_clean$rating_kp, df_clean$total_dur, method = "kendall")
##
## Kendall's rank correlation tau
##
## data: df_clean$rating_kp and df_clean$total_dur
## z = 1.2928, p-value = 0.1961
## alternative hypothesis: true tau is not equal to 0
## sample estimates:
## tau
## 0.009862392
Значение tau близко к нулю (0.009), что указывает на практически полное отсутствие линейной связи между рейтингом фильмов и длительностью их просмотра
p-value = 0.1961 (больше 0.05) подтверждает, что наблюдаемая очень слабая корреляция не является статистически значимой
library(ggpubr)
# точечная диаграмма с линией регрессии
ggscatter(df_clean, x = "rating_kp", y = "total_dur",
add = "reg.line", conf.int = FALSE, cor.method = "kendall",
size = 3, shape = 21,
color = "lightblue", fill = "orange",
xlab = "Рейтинг на Кинопоиске", ylab = "Продолжительность просмотора (сек) -\nлогарифмированная",
title = "Корреляция рейтинга и продолжительности просмотра"
) + scale_y_log10() # логарифмическая шкала для сильно скошенных данных
# плотность распределения
ggplot(df_clean, aes(x = rating_kp, y = total_dur)) +
geom_hex(bins = 30) +
geom_smooth(formula = y ~ x, method = "lm", color = "orange", se = FALSE) +
scale_y_log10() +
labs(title = "Плотность распределения продолжительности просмотра по рейтингу", x = "Рейтинг на Кинопоиске", y = "Продолжительность просмотора (сек) -\nлогарифмированная") +
theme_minimal()
# Boxplot для распределения времени просмотра по разным рейтингам (значение рейтинга округлено)
ggplot(df_clean, aes(x = factor(round(rating_kp)), y = total_dur)) +
geom_boxplot(fill = "orange", color = "#45818e") +
labs(title = "Продолжительность просмотра по рейтингу", x = "Округленный рейтинг", y = "Продолжительность просмотора (сек)") +
theme_minimal()
H₀ (нулевая гипотеза): Между полом пользователя и типом контента, который он просматривает, отсутствует сатистически значимая связь
H₁ (альтернативная гипотеза): Существует статистически значимая свзяь между полом пользователя и типом контента, который он просматривает
Так как мы хотим проверить, есть ли связь между двумя категориальными переменными, используем тест Хи-квадрат на независимость или тест Фишера
Допущения о независимости переменных и количестве наблюдений (7837) соблюдены
Создадим таблицу сопряженности переменных sex и
content_type
contingency_table <- table(df_clean$sex, df_clean$content_type)
contingency_table
##
## film series
## Ж 2990 737
## М 3520 590
Проверим ожидаемые частоты
chisq <- chisq.test(contingency_table)
round(chisq$expected)
##
## film series
## Ж 3096 631
## М 3414 696
Видим, что условие соблюдено - все значения ≥5, можно использовать тест Хи-квадрат на независимость
chisq
##
## Pearson's Chi-squared test with Yates' continuity correction
##
## data: contingency_table
## X-squared = 40.429, df = 1, p-value = 2.039e-10
p-value = 2.039e-10 < 0.05: Отвергаем H₀, связь между полом и типом контента статистически значима
Посмотрим на направление связи (стандартизированные остатки)
round(chisq$stdres)
##
## film series
## Ж -6 6
## М 6 -6
Все отклонения = 6 (по модулю), а значит можно считать их очень сильными (> 3)
У женщин наблюдаемая частота просмотра сериалов (series) на 6 выше, а у мужчин на 6 ниже ожидаемой, значит, женщины чаще смотрят сериалы, чем мужчины
У женщин наблюдаемая частота просмотра фильмов на 6 ниже ожидаемой, а у мужчин на 6 выше ожидаемой, значит, мужчины чаще смотрят фильмы, чем женщины
# мозаичная диаграмма
mosaicplot(contingency_table,
main = "Связь пола и типа контента",
xlab = "Пол",
ylab = "Тип контента",
col = c("#8fce00", "#674ea7"))
# столбчатая диаграмма
ggplot(as.data.frame(contingency_table), aes(x = Var1, y = Freq, fill = Var2)) +
geom_bar(stat = "identity", position = "dodge") +
labs(x = "Пол", y = "Количество", fill = "Тип контента") +
scale_fill_manual(values = c("film" = "#8fce00", "series" = "#674ea7")) +
theme_minimal()
library(corrplot)
# визуализируем остатки
corrplot(chisq$residuals, method = "circle", type = "full", is.cor=FALSE)
H₀ (нулевая гипотеза): Между типом контента, который просматривает пользователь, и уровнем его дохода отсутствует статистически значимая связь
H₁ (альтернативная гипотеза): Существует статистически значимая свзяь между типом контента, который просматривает пользователь, и уровнем его дохода
Так как мы хотим проверить, есть ли связь между двумя категориальными переменными, используем тест Хи-квадрат на независимость или тест Фишера
Допущения о независимости переменных и количестве наблюдений (7837) соблюдены
Создадим таблицу сопряженности переменных income и
content_type
contingency_table <- table(df_clean$income, df_clean$content_type)
contingency_table
##
## film series
## income_0_20 124 48
## income_20_40 3707 720
## income_40_60 2031 412
## income_60_90 536 115
## income_90_150 108 29
## income_150_inf 4 3
Проверим ожидаемые частоты
chisq <- chisq.test(contingency_table)
round(chisq$expected)
##
## film series
## income_0_20 143 29
## income_20_40 3677 750
## income_40_60 2029 414
## income_60_90 541 110
## income_90_150 114 23
## income_150_inf 6 1
Видим, что условие соблюдено - все значения (кроме series для income_150_inf) ≥5, будем использовать Хи-квадрат на независимость
chisq
##
## Pearson's Chi-squared test
##
## data: contingency_table
## X-squared = 21.484, df = 5, p-value = 0.0006561
p-value = 0.0007 < 0.05: Отвергаем H₀, связь между доходом и типом контента статистически значима
Посмотрим на направление связи (стандартизированные остатки)
round(chisq$stdres)
##
## film series
## income_0_20 -4 4
## income_20_40 2 -2
## income_40_60 0 0
## income_60_90 -1 1
## income_90_150 -1 1
## income_150_inf -2 2
У пользователей с доходом от 0 до 20000 р. самое сильное отклонение от ожидаемого (4) - они чаще смотрят сериалы, чем пользователи с другим доходом
Пользователи с доходом от 20000 до 40000 р. также имеют довольно значительное отклонение (2) - они, наоборот, чаще смотрят фильмы, чем пользователи с другим доходом
Пользователи с доходом от 150000 р. (отклонение = 2) чаще смотрят сериалы, чем пользователи с другим доходои
Для пользователей с доходом от 40000 до 60000 р. фактическое наблюдение совпало с ожидаемым (0); для групп от 60000 до 150000 р. отклонения также были незначимым (1), что говорит об отсутствии конкретных предпочтений для этих групп
# столбчатая диаграмма
ggplot(as.data.frame(contingency_table), aes(x = Var1, y = Freq, fill = Var2)) +
geom_bar(stat = "identity", position = "dodge") +
labs(x = "Доход", y = "Количество", fill = "Тип контента") +
scale_fill_manual(values = c("film" = "#8fce00", "series" = "#674ea7")) +
theme_minimal()
# визуализируем остатки
corrplot(chisq$residuals, method = "circle", type = "full", is.cor=FALSE)